home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog6.arj / SLIDES.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  5.1 KB  |  203 lines
  1. { slides.pas -- Slide show of .BMP files }
  2.  
  3. {$DEFINE FullSize}  { Remove this line to scale images }
  4.  
  5. program Slides;
  6.  
  7. uses WinTypes, WinProcs, WObjects, Strings, UBitmap;
  8.  
  9. const
  10.  
  11.   timer_ID  = 1;    { Local timer id number }
  12. (*  numSlides = 7;    { Windows 3.0 } *)
  13.   numSlides = 3;    { Windows 3.1 }
  14.   secsToPause = 8;  { Seconds to pause between slides }
  15.  
  16. {- Array of slide file names. Must contain at least one entry. }
  17.  
  18.   slideNames: array[0 .. numSlides - 1] of PChar = (
  19.  
  20. { Windows 3.1 }
  21.      'c:\tpw\owldemos\blaise.bmp',
  22.      'c:\tpw\owldemos\nolimits.bmp',
  23.      'c:\tpw\owldemos\racecar.bmp'
  24.  
  25. { Windows 3.0 }
  26. (*
  27.      'c:\windows\chess.bmp',
  28.      'c:\windows\party.bmp',
  29.      'c:\windows\paper.bmp',
  30.      'c:\windows\ribbons.bmp'
  31. *)
  32.  
  33.   );
  34.  
  35. type
  36.  
  37.   SlidesApplication = object(TApplication)
  38.     procedure InitMainWindow; virtual;
  39.   end;
  40.  
  41.   PSlidesWindow = ^SlidesWindow;
  42.   SlidesWindow = object(TWindow)
  43.     SlideBitmap: HBitmap;   { Handle to bitmap in memory }
  44.     Width, Height: LongInt; { Size of bitmap image }
  45.     ImageIndex: Integer;    { Current slideNames file name }
  46.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  47.     destructor Done;
  48.       virtual;
  49.     procedure DeleteOldObjects;
  50.     procedure SetupWindow;
  51.       virtual;
  52.     procedure WMDestroy(var Msg: TMessage);
  53.       virtual wm_First + wm_Destroy;
  54.     procedure WMTimer(var Msg: TMessage);
  55.       virtual wm_First + wm_Timer;
  56.     procedure WMLButtonDown(var Msg: TMessage);
  57.       virtual wm_First + wm_LButtonDown;
  58.     procedure WMKeyDown(var Msg: TMessage);
  59.       virtual wm_First + wm_KeyDown;
  60.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  61.       virtual;
  62.     procedure LoadImage(FileName: PChar);
  63.   end;
  64.  
  65.  
  66. { SlidesApplication }
  67.  
  68. {- Initialize SlidesApplication object's window }
  69. procedure SlidesApplication.InitMainWindow;
  70. begin
  71.   MainWindow := New(PSlidesWindow, Init(nil, 'Slide Show'))
  72. end;
  73.  
  74.  
  75. { SlidesWindow }
  76.  
  77. {- Construct SlidesWindow and prepare full-screen window. }
  78. constructor SlidesWindow.Init(AParent: PWindowsObject;
  79.   ATitle: PChar);
  80. begin
  81.   TWindow.Init(AParent, ATitle);
  82.   SlideBitmap := 0;
  83.   with Attr do
  84.   begin
  85.     X := 0;
  86.     Y := 0;
  87.     W := GetSystemMetrics(sm_CXScreen);
  88.     H := GetSystemMetrics(sm_CYScreen);
  89.     Style := ws_PopUp or ws_Maximize
  90.   end;
  91.   LoadImage(slideNames[0]);       { Load initial image }
  92.   ShowCursor(false);              { Hide cursor }
  93.   ImageIndex := 0
  94. end;
  95.  
  96. {- Dispose of any bitmap image in memory }
  97. destructor SlidesWindow.Done;
  98. begin
  99.   DeleteOldObjects;
  100.   ShowCursor(true);
  101.   TWindow.Done
  102. end;
  103.  
  104. {- Dispose of any SlidesWindow structures }
  105. procedure SlidesWindow.DeleteOldObjects;
  106. begin
  107.   if SlideBitmap <> 0 then DeleteObject(SlideBitmap);
  108.   SlideBitmap := 0   { Prevent deleting twice }
  109. end;
  110.  
  111. {- Engage a timer for pausing between slides }
  112. procedure SlidesWindow.SetupWindow;
  113. begin
  114.   TWindow.SetupWindow;
  115.   SetTimer(HWindow, timer_ID, 1000 * secsToPause, nil)
  116. end;
  117.  
  118. {- Intercept wm_Destroy message }
  119. procedure SlidesWindow.WMDestroy(var Msg: TMessage);
  120. begin
  121.   KillTimer(hWindow, timer_ID);
  122.   TWindow.WMDestroy(Msg)
  123. end;
  124.  
  125. {- Timer has gone off: switch to next slide }
  126. procedure SlidesWindow.WMTimer(var Msg: TMessage);
  127. begin
  128.   if numSlides > 1 then  { No sense changing only one slide! }
  129.   begin
  130.     Inc(ImageIndex);
  131.     if ImageIndex >= numSlides then ImageIndex := 0;
  132.     LoadImage(slideNames[ImageIndex])
  133.   end
  134. end;
  135.  
  136. {- Exit program on clicking left mouse button }
  137. procedure SlidesWindow.WMLButtonDown(var Msg: TMessage);
  138. begin
  139.   CloseWindow
  140. end;
  141.  
  142. {- Exit program on any key press }
  143. procedure SlidesWindow.WMKeyDown(var Msg: TMessage);
  144. begin
  145.   CloseWindow
  146. end;
  147.  
  148. {- Load bitmap image from disk into memory }
  149. procedure SlidesWindow.LoadImage(FileName: PChar);
  150. var
  151.   BitMapH: HBitMap;
  152. begin
  153.   DeleteOldObjects;  { Delete old bitmap if any }
  154.   BitMapH := LoadBitmap(FileName, HWindow, Width, Height);
  155.   if BitMapH = 0 then
  156.   begin
  157.     ShowCursor(true);
  158.     MessageBox(HWindow, FileName, 'Error Loading File',
  159.       mb_IconExclamation or mb_Ok);
  160.     ShowCursor(false);
  161.     CloseWindow   { Exit on any file error }
  162.   end else
  163.   begin
  164.     SlideBitmap := BitMapH;
  165.     InvalidateRect(HWindow, nil, true)  { Force repaint }
  166.   end
  167. end;
  168.  
  169. {- Paint or repaint the window, showing current slide }
  170. procedure SlidesWindow.Paint(PaintDC: HDC;
  171.   var PaintInfo: TPaintStruct);
  172. var
  173.   MemDC: HDC;
  174.   R: TRect;
  175. begin
  176.   MemDC := CreateCompatibleDC(PaintDC);
  177.   SelectObject(MemDC, SlideBitmap);
  178. {$IFDEF FullSize}
  179.   BitBlt(PaintDC, 0, 0, Width, Height, MemDC, 0, 0, SRCCopy);
  180. {$ELSE}
  181.   GetClientRect(HWindow, R);
  182.   StretchBlt(PaintDC, 0, 0, R.Right, R.Bottom,
  183.     MemDC, 0, 0, Width, Height, SRCCopy);
  184. {$ENDIF}
  185.   DeleteDC(MemDC)
  186. end;
  187.  
  188. var
  189.  
  190.   SlidesApp: SlidesApplication;
  191.  
  192. begin
  193.   SlidesApp.Init('SlidesApp');
  194.   SlidesApp.Run;
  195.   SlidesApp.Done
  196. end.
  197.  
  198.  
  199. {--------------------------------------------------------------
  200.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  201.   Revision 1.00    Date: 2/25/1991
  202. ---------------------------------------------------------------}
  203.